home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / Compiler / out-fast.em < prev    next >
Lisp/Scheme  |  1993-07-03  |  3KB  |  122 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: out-mod.em
  4. ;; Date: Mon Nov 23 17:11:52 1992
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;   Fast reading/linking and writing
  9. ;;   or interface files
  10.  
  11. (defmodule out-fast
  12.   (standard0
  13.    list-fns
  14.  
  15.    comp-utl
  16.    comp-defn
  17.    )
  18.   ()
  19.  
  20.   (defclass Compiler-Error (<condition>)
  21.     ()
  22.     metaclass <condition-class>)
  23.  
  24.   ;; Format is:
  25.   ;; code-length
  26.   ;; nslots
  27.   ;; statics
  28.   ;; bytecodes
  29.   ;; a bytecode is: 
  30.   ;;   byte
  31.   ;;   (nonlocal . value)
  32.   (export write-fastbytes)
  33.  
  34.   (defun write-fastbytes (unit)
  35.     (let ((file (open (fast-file-name (car (sc-names unit))) 'output t)))
  36.       (write (sc-dependencies unit) file)
  37.       (newline file)
  38.       (write (sc-nslots unit) file)
  39.       (newline file)
  40.       (write (sc-length unit) file)
  41.       (newline file)
  42.       (write (sc-statics unit) file)
  43.       (newline file)
  44.       (write-bytecode-list unit file)
  45.       (close file)))
  46.  
  47.   (defconstant big-arg-symbol (the-long-handle))
  48.   (defconstant link-symbol (the-link-handle))
  49.   (defconstant local-symbol (the-local-handle))
  50.   (defconstant static-symbol (the-static-handle))
  51.  
  52.   (defun write-bytecode-list (unit file)
  53.     (let ((local-alloc (mk-local-alloc (first-posn unit))))
  54.       (mapc (lambda (i)
  55.           (write-instruction i local-alloc file))
  56.         (sc-code unit))))
  57.   
  58.   (defun first-posn (unit)
  59.     (+ 1 (list-length (sc-statics unit))))
  60.  
  61.   (defun write-instruction (lst local-alloc file)
  62.     (cond ((null lst) nil)
  63.       ((atom (car lst))
  64.        (write (car lst) file)
  65.        (newline file)
  66.        (write-instruction (cdr lst) local-alloc file))
  67.       ((eq (caar lst) local-symbol)
  68.        (write-bignum (local-alloc (cdr (car lst))) file)
  69.        (newline file)
  70.        (write-instruction (cdr lst) local-alloc file))
  71.       ((eq (caar lst) big-arg-symbol)
  72.        (write-bignum (cadar lst) file)
  73.        (newline file)
  74.        (write-instruction (cdr lst) local-alloc file))
  75.       ((eq (caar lst) static-symbol)
  76.        (write-bignum (+ (cdr (car lst)) 1) file)
  77.        (newline file)
  78.        (write-instruction (cdr lst) local-alloc file))
  79.       ((not (eq (caar lst) link-symbol))
  80.        (error "unknown object type" Compiler-Error 'error-value (car lst)))
  81.       ((eq (cadar lst) local-symbol)
  82.        (error "Can't deal with non-optimised code" Compiler-Error 'error-value (car lst)))
  83.       (t (write (cdar lst) file)
  84.          (newline file)
  85.          (write-instruction (cdr lst) local-alloc file))))
  86.  
  87.   (defun mk-local-alloc (start)
  88.     (let ((count start)
  89.       (finder (mk-finder)))
  90.       (lambda (name)
  91.     (let ((cached-name (finder name)))
  92.       (if (null cached-name)
  93.           (progn (let ((this-val count))
  94.                (setq count (+ count 1))
  95.                ((setter finder) name this-val)
  96.                this-val))
  97.         cached-name)))))
  98.   
  99.   (defun space (file)
  100.     (prin " " file))
  101.  
  102.   (defun write-bignum (n file)
  103.     (mapc (lambda (x)
  104.         (write x file) (space file))
  105.       (int2bytes n)))
  106.  
  107.   ;; making 4 bytes from integers.
  108.  
  109.   (defun int2bytes (x)
  110.     (let ((sign (< x 0))
  111.       (val (abs x)))
  112.       (let* ((v1 (/ val 256))
  113.          (v2 (/ v1 256))
  114.          (v3 (/ v2 256)))
  115.     (list (modulo v2 256)
  116.           (modulo v1 256)
  117.           (modulo val 256)
  118.           (if sign 1 0)))))
  119.   
  120.   ;; end module
  121.   )
  122.